home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / tclsrc / help.tcl < prev    next >
Encoding:
Text File  |  1993-10-26  |  9.8 KB  |  326 lines  |  [TEXT/MPS ]
  1. #
  2. # help.tcl --
  3. #
  4. # Tcl help command. (see TclX manual)
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # The help facility is based on a hierarchical tree of subjects (directories)
  17. # and help pages (files).  There is a virtual root to this tree. The root
  18. # being the merger of all "help" directories found along the $auto_path
  19. # variable.
  20. #------------------------------------------------------------------------------
  21. # $Id: help.tcl,v 2.5 1993/06/24 07:30:29 markd Exp $
  22. #------------------------------------------------------------------------------
  23. #
  24.  
  25. #@package: TclX-help help helpcd helppwd apropos
  26.  
  27. #------------------------------------------------------------------------------
  28. # Return a list of help root directories.
  29.  
  30. proc help:RootDirs {} {
  31.     global auto_path
  32.     set roots {}
  33.     foreach dir $auto_path {
  34.         if [file isdirectory $dir/help] {
  35.             lappend roots $dir/help
  36.         }
  37.     }
  38.     return $roots
  39. }
  40.  
  41. #------------------------------------------------------------------------------
  42. # Take a path name which might have "." and ".." elements and flatten them out.
  43. # Also removes trailing and adjacent "/", unless its the only character.
  44.  
  45. proc help:FlattenPath pathName {
  46.     set newPath {}
  47.     foreach element [split $pathName /] {
  48.         if {"$element" == "." || [lempty $element]} continue
  49.  
  50.         if {"$element" == ".."} {
  51.             if {[llength [join $newPath /]] == 0} {
  52.                 error "Help: name goes above subject directory root"}
  53.             lvarpop newPath [expr [llength $newPath]-1]
  54.             continue
  55.         }
  56.         lappend newPath $element
  57.     }
  58.     set newPath [join $newPath /]
  59.  
  60.     # Take care of the case where we started with something line "/" or "/."
  61.  
  62.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  63.         set newPath "/"
  64.     }
  65.         
  66.     return $newPath
  67. }
  68.  
  69. #------------------------------------------------------------------------------
  70. # Given a pathName relative to the virtual help root, convert it to a list of
  71. # real file paths.  A list is returned because the path could be "/", returning
  72. # a list of all roots. The list is returned in the same order of the auto_path
  73. # variable. If path does not start with a "/", it is take as relative to the
  74. # current help subject.  Note:  The root directory part of the name is not
  75. # flattened.  This lets other commands pick out the part relative to the
  76. # one of the root directories.
  77.  
  78. proc help:ConvertPath pathName {
  79.     global TCLENV
  80.  
  81.     if {![string match "/*" $pathName]} {
  82.         if {"$TCLENV(help:curSubject)" == "/"} {
  83.             set pathName "/$pathName"
  84.         } else {
  85.             set pathName "$TCLENV(help:curSubject)/$pathName"
  86.         }
  87.     }
  88.     set pathName [help:FlattenPath $pathName]
  89.  
  90.     # If the virtual root is specified, return a list of directories.
  91.  
  92.     if {$pathName == "/"} {
  93.         return [help:RootDirs]
  94.     }
  95.  
  96.     # Not the virtual root find the first match.
  97.  
  98.     foreach dir [help:RootDirs] {
  99.         if [file readable $dir/$pathName] {
  100.             return [list $dir/$pathName]
  101.         }
  102.     }
  103.     error "\"$pathName\" does not exist"
  104. }
  105.  
  106. #------------------------------------------------------------------------------
  107. # Return the virtual root relative name of the file given its absolute path.
  108. # The root part of the path should not have been flattened, as we would not
  109. # be able to match it.
  110.  
  111. proc help:RelativePath pathName {
  112.     foreach dir [help:RootDirs] {
  113.         if {[csubstr $pathName 0 [clength $dir]] == $dir} {
  114.             set name [csubstr $pathName [clength $dir] end]
  115.             if {$name == ""} {set name /}
  116.             return $name
  117.         }
  118.     }
  119.     if ![info exists found] {
  120.         error "problem translating \"$pathName\""
  121.     }
  122.  
  123. }
  124.  
  125. #------------------------------------------------------------------------------
  126. # Given a list of path names to subjects generated by ConvertPath, return
  127. # the contents of the subjects.  Two lists are returned, subjects under that
  128. # subject and a list of pages under the subject.  Both lists are returned
  129. # sorted.  This merges all the roots into a virtual root.  pathName is the
  130. # string that was passed to ConvertPath and is used for error reporting.
  131. # *.brk files are not returned.
  132.  
  133. proc help:ListSubject {pathName pathList subjectsVar pagesVar} {
  134.     upvar $subjectsVar subjects $pagesVar pages
  135.  
  136.     set subjects {}
  137.     set pages {}
  138.     set foundDir 0
  139.     foreach dir $pathList {
  140.         if ![file isdirectory $dir] continue
  141.         set foundDir 1
  142.         foreach file [glob -nocomplain $dir/*] {
  143.             if [string match *.brf $file] continue
  144.             if [file isdirectory $file] {
  145.                 lappend subjects [file tail $file]/
  146.             } else {
  147.                 lappend pages [file tail $file]
  148.             }
  149.         }
  150.     }
  151.     if !$foundDir {
  152.         error "\"$pathName\" is not a subject"
  153.     }
  154.     set subjects [lsort $subjects]
  155.     set pages [lsort $pages]
  156.     return {}
  157. }
  158.  
  159. #------------------------------------------------------------------------------
  160. # Display a line of output, pausing waiting for input before displaying if the
  161. # screen size has been reached.  Return 1 if output is to continue, return
  162. # 0 if no more should be outputed, indicated by input other than return.
  163. #
  164.  
  165. proc help:Display line {
  166.     global TCLENV
  167.     if {$TCLENV(help:lineCnt) >= 23} {
  168.         set TCLENV(help:lineCnt) 0
  169.         puts stdout ":" nonewline
  170.         flush stdout
  171.         gets stdin response
  172.         if {![lempty $response]} {
  173.             return 0}
  174.     }
  175.     puts stdout $line
  176.     incr TCLENV(help:lineCnt)
  177. }
  178.  
  179. #------------------------------------------------------------------------------
  180. # Display a help page (file).
  181.  
  182. proc help:DisplayPage filePath {
  183.  
  184.     set inFH [open $filePath r]
  185.     while {[gets $inFH fileBuf] >= 0} {
  186.         if {![help:Display $fileBuf]} {
  187.             break}
  188.     }
  189.     close $inFH
  190. }    
  191.  
  192. #------------------------------------------------------------------------------
  193. # Display a list of file names in a column format. This use columns of 14 
  194. # characters 3 blanks.
  195.  
  196. proc help:DisplayColumns {nameList} {
  197.     set count 0
  198.     set outLine ""
  199.     foreach name $nameList {
  200.         if {$count == 0} {
  201.             append outLine "   "}
  202.         append outLine $name
  203.         if {[incr count] < 4} {
  204.             set padLen [expr 17-[clength $name]]
  205.             if {$padLen < 3} {
  206.                set padLen 3}
  207.             append outLine [replicate " " $padLen]
  208.         } else {
  209.            if {![help:Display $outLine]} {
  210.                return}
  211.            set outLine ""
  212.            set count 0
  213.         }
  214.     }
  215.     if {$count != 0} {
  216.         help:Display [string trimright $outLine]}
  217.     return
  218. }
  219.  
  220. #------------------------------------------------------------------------------
  221. # Display help on help, the first occurance of a help page called "help" in
  222. # the help root.
  223.  
  224. proc help:HelpOnHelp {} {
  225.     set helpPage [lindex [help:ConvertPath /help] 0]
  226.     if [lempty $helpPage] {
  227.         error "No help page on help found"
  228.     }
  229.     help:DisplayFile $helpPage
  230. }
  231.  
  232. #------------------------------------------------------------------------------
  233. # Help command.
  234.  
  235. proc help {{what {}}} {
  236.     global TCLENV
  237.  
  238.     set TCLENV(help:lineCnt) 0
  239.  
  240.     # Special case "help help", so we can get it at any level.
  241.  
  242.     if {($what == "help") || ($what == "?")} {
  243.         help:HelpOnHelp
  244.         return
  245.     }
  246.  
  247.     set pathList [help:ConvertPath $what]
  248.     if [file isfile [lindex $pathList 0]] {
  249.         help:DisplayPage [lindex $pathList 0]
  250.         return
  251.     }
  252.  
  253.     help:ListSubject $what $pathList subjects pages
  254.     set relativeDir [help:RelativePath [lindex $pathList 0]]
  255.  
  256.     if {[llength $subjects] != 0} {
  257.         help:Display "\nSubjects available in $relativeDir:"
  258.         help:DisplayColumns $subjects
  259.     }
  260.     if {[llength $pages] != 0} {
  261.         help:Display "\nHelp pages available in $relativeDir:"
  262.         help:DisplayColumns $pages
  263.     }
  264. }
  265.  
  266.  
  267. #------------------------------------------------------------------------------
  268. # helpcd command.  The name of the new current directory is assembled from the
  269. # current directory and the argument.
  270.  
  271. proc helpcd {{dir /}} {
  272.     global TCLENV
  273.  
  274.     set pathName [lindex [help:ConvertPath $dir] 0]
  275.  
  276.     if {![file isdirectory $pathName]} {
  277.         error "Helpcd: \"$dir\" is not a subject"}
  278.  
  279.     set TCLENV(help:curSubject) [help:RelativePath $pathName]
  280.     return
  281. }
  282.  
  283. #------------------------------------------------------------------------------
  284. # Helpcd main.
  285.  
  286. proc helppwd {} {
  287.         global TCLENV
  288.         echo "Current help subject: $TCLENV(help:curSubject)"
  289. }
  290.  
  291. #------------------------------------------------------------------------------
  292. # apropos command.  This search the 
  293.  
  294. proc apropos {regexp} {
  295.     global TCLENV
  296.  
  297.     set TCLENV(help:lineCnt) 0
  298.  
  299.     set ch [scancontext create]
  300.     scanmatch -nocase $ch $regexp {
  301.         set path [lindex $matchInfo(line) 0]
  302.         set desc [lrange $matchInfo(line) 1 end]
  303.         if {![help:Display [format "%s - %s" $path $desc]]} {
  304.             set stop 1
  305.             return}
  306.     }
  307.     set stop 0
  308.     foreach dir [help:RootDirs] {
  309.         foreach brief [glob -nocomplain $dir/*.brf] {
  310.             set briefFH [open $brief]
  311.             scanfile $ch $briefFH
  312.             close $briefFH
  313.             if $stop break
  314.         }
  315.         if $stop break
  316.     }
  317.     scancontext delete $ch
  318. }
  319.  
  320. #------------------------------------------------------------------------------
  321. # One time initialization done when the file is sourced.
  322. #
  323. global TCLENV
  324.  
  325. set TCLENV(help:curSubject) "/"
  326.